home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / apel / std11.el.z / std11.el
Encoding:
Text File  |  1998-05-21  |  10.1 KB  |  374 lines
  1. ;;; std11.el --- STD 11 functions for GNU Emacs
  2.  
  3. ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author:   MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Keywords: mail, news, RFC 822, STD 11
  7. ;; Version: $Id: std11.el,v 0.40 1997/03/03 08:03:06 shuhei-k Exp $
  8.  
  9. ;; This file is part of MU (Message Utilities).
  10.  
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 2, or (at
  14. ;; your option) any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Code:
  27.  
  28. (autoload 'buffer-substring-no-properties "emu")
  29. (autoload 'member "emu")
  30.  
  31.  
  32. ;;; @ field
  33. ;;;
  34.  
  35. (defconst std11-field-name-regexp "[!-9;-~]+")
  36. (defconst std11-field-head-regexp
  37.   (concat "^" std11-field-name-regexp ":"))
  38. (defconst std11-next-field-head-regexp
  39.   (concat "\n" std11-field-name-regexp ":"))
  40.  
  41. (defun std11-field-end ()
  42.   "Move to end of field and return this point. [std11.el]"
  43.   (if (re-search-forward std11-next-field-head-regexp nil t)
  44.       (goto-char (match-beginning 0))
  45.     (if (re-search-forward "^$" nil t)
  46.     (goto-char (1- (match-beginning 0)))
  47.       (end-of-line)
  48.       ))
  49.   (point)
  50.   )
  51.  
  52. (defun std11-field-body (name &optional boundary)
  53.   "Return body of field NAME.
  54. If BOUNDARY is not nil, it is used as message header separator.
  55. \[std11.el]"
  56.   (save-excursion
  57.     (save-restriction
  58.       (std11-narrow-to-header boundary)
  59.       (goto-char (point-min))
  60.       (let ((case-fold-search t))
  61.     (if (re-search-forward (concat "^" name ":[ \t]*") nil t)
  62.         (buffer-substring-no-properties (match-end 0) (std11-field-end))
  63.       )))))
  64.  
  65. (defun std11-find-field-body (field-names &optional boundary)
  66.   "Return the first found field-body specified by FIELD-NAMES
  67. of the message header in current buffer. If BOUNDARY is not nil, it is
  68. used as message header separator. [std11.el]"
  69.   (save-excursion
  70.     (save-restriction
  71.       (std11-narrow-to-header boundary)
  72.       (let ((case-fold-search t)
  73.         field-name)
  74.     (catch 'tag
  75.       (while (setq field-name (car field-names))
  76.         (goto-char (point-min))
  77.         (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
  78.         (throw 'tag
  79.                (buffer-substring-no-properties
  80.             (match-end 0) (std11-field-end)))
  81.           )
  82.         (setq field-names (cdr field-names))
  83.         ))))))
  84.  
  85. (defun std11-field-bodies (field-names &optional default-value boundary)
  86.   "Return list of each field-bodies of FIELD-NAMES of the message header
  87. in current buffer. If BOUNDARY is not nil, it is used as message
  88. header separator. [std11.el]"
  89.   (save-excursion
  90.     (save-restriction
  91.       (std11-narrow-to-header boundary)
  92.       (let* ((case-fold-search t)
  93.          (dest (make-list (length field-names) default-value))
  94.          (s-rest field-names)
  95.          (d-rest dest)
  96.          field-name)
  97.     (while (setq field-name (car s-rest))
  98.       (goto-char (point-min))
  99.       (if (re-search-forward (concat "^" field-name ":[ \t]*") nil t)
  100.           (setcar d-rest
  101.               (buffer-substring-no-properties
  102.                (match-end 0) (std11-field-end)))
  103.         )
  104.       (setq s-rest (cdr s-rest)
  105.         d-rest (cdr d-rest))
  106.       )
  107.     dest))))
  108.  
  109.  
  110. ;;; @ unfolding
  111. ;;;
  112.  
  113. (defun std11-unfold-string (string)
  114.   "Unfold STRING as message header field. [std11.el]"
  115.   (let ((dest ""))
  116.     (while (string-match "\n\\([ \t]\\)" string)
  117.       (setq dest (concat dest
  118.                          (substring string 0 (match-beginning 0))
  119.                          (match-string 1 string)
  120.                          ))
  121.       (setq string (substring string (match-end 0)))
  122.       )
  123.     (concat dest string)
  124.     ))
  125.  
  126.  
  127. ;;; @ header
  128. ;;;
  129.  
  130. (defun std11-narrow-to-header (&optional boundary)
  131.   "Narrow to the message header.
  132. If BOUNDARY is not nil, it is used as message header separator.
  133. \[std11.el]"
  134.   (narrow-to-region
  135.    (goto-char (point-min))
  136.    (if (re-search-forward
  137.     (concat "^\\(" (regexp-quote (or boundary "")) "\\)?$")
  138.     nil t)
  139.        (match-beginning 0)
  140.      (point-max)
  141.      )))
  142.  
  143. (defun std11-header-string (regexp &optional boundary)
  144.   "Return string of message header fields matched by REGEXP.
  145. If BOUNDARY is not nil, it is used as message header separator.
  146. \[std11.el]"
  147.   (let ((case-fold-search t))
  148.     (save-excursion
  149.       (save-restriction
  150.     (std11-narrow-to-header boundary)
  151.     (goto-char (point-min))
  152.     (let (field header)
  153.       (while (re-search-forward std11-field-head-regexp nil t)
  154.         (setq field
  155.           (buffer-substring (match-beginning 0) (std11-field-end)))
  156.         (if (string-match regexp field)
  157.         (setq header (concat header field "\n"))
  158.           ))
  159.       header)
  160.     ))))
  161.  
  162. (defun std11-header-string-except (regexp &optional boundary)
  163.   "Return string of message header fields not matched by REGEXP.
  164. If BOUNDARY is not nil, it is used as message header separator.
  165. \[std11.el]"
  166.   (let ((case-fold-search t))
  167.     (save-excursion
  168.       (save-restriction
  169.     (std11-narrow-to-header boundary)
  170.     (goto-char (point-min))
  171.     (let (field header)
  172.       (while (re-search-forward std11-field-head-regexp nil t)
  173.         (setq field
  174.           (buffer-substring (match-beginning 0) (std11-field-end)))
  175.         (if (not (string-match regexp field))
  176.         (setq header (concat header field "\n"))
  177.           ))
  178.       header)
  179.     ))))
  180.  
  181. (defun std11-collect-field-names (&optional boundary)
  182.   "Return list of all field-names of the message header in current buffer.
  183. If BOUNDARY is not nil, it is used as message header separator.
  184. \[std11.el]"
  185.   (save-excursion
  186.     (save-restriction
  187.       (std11-narrow-to-header boundary)
  188.       (goto-char (point-min))
  189.       (let (dest name)
  190.     (while (re-search-forward std11-field-head-regexp nil t)
  191.       (setq name (buffer-substring-no-properties
  192.               (match-beginning 0)(1- (match-end 0))))
  193.       (or (member name dest)
  194.           (setq dest (cons name dest))
  195.           )
  196.       )
  197.     dest))))
  198.  
  199.  
  200. ;;; @ quoted-string
  201. ;;;
  202.  
  203. (defun std11-wrap-as-quoted-pairs (string specials)
  204.   (let (dest
  205.     (i 0)
  206.     (b 0)
  207.     (len (length string))
  208.     )
  209.     (while (< i len)
  210.       (let ((chr (aref string i)))
  211.     (if (memq chr specials)
  212.         (setq dest (concat dest (substring string b i) "\\")
  213.           b i)
  214.       ))
  215.       (setq i (1+ i))
  216.       )
  217.     (concat dest (substring string b))
  218.     ))
  219.  
  220. (defconst std11-non-qtext-char-list '(?\" ?\\ ?\r ?\n))
  221.  
  222. (defun std11-wrap-as-quoted-string (string)
  223.   "Wrap STRING as RFC 822 quoted-string. [std11.el]"
  224.   (concat "\""
  225.       (std11-wrap-as-quoted-pairs string std11-non-qtext-char-list)
  226.       "\""))
  227.  
  228. (defun std11-strip-quoted-pair (string)
  229.   "Strip quoted-pairs in STRING. [std11.el]"
  230.   (let (dest
  231.     (b 0)
  232.     (i 0)
  233.     (len (length string))
  234.     )
  235.     (while (< i len)
  236.       (let ((chr (aref string i)))
  237.     (if (eq chr ?\\)
  238.         (setq dest (concat dest (substring string b i))
  239.           b (1+ i)
  240.           i (+ i 2))
  241.       (setq i (1+ i))
  242.       )))
  243.     (concat dest (substring string b))
  244.     ))
  245.  
  246. (defun std11-strip-quoted-string (string)
  247.   "Strip quoted-string STRING. [std11.el]"
  248.   (let ((len (length string)))
  249.     (or (and (>= len 2)
  250.          (let ((max (1- len)))
  251.            (and (eq (aref string 0) ?\")
  252.             (eq (aref string max) ?\")
  253.             (std11-strip-quoted-pair (substring string 1 max))
  254.             )))
  255.     string)))
  256.  
  257.  
  258. ;;; @ composer
  259. ;;;
  260.  
  261. (defun std11-addr-to-string (seq)
  262.   "Return string from lexical analyzed list SEQ
  263. represents addr-spec of RFC 822. [std11.el]"
  264.   (mapconcat (function
  265.           (lambda (token)
  266.         (let ((name (car token)))
  267.                   (cond
  268.                    ((eq name 'spaces) "")
  269.                    ((eq name 'comment) "")
  270.                    ((eq name 'quoted-string)
  271.                     (concat "\"" (cdr token) "\""))
  272.                    (t (cdr token)))
  273.                   )))
  274.          seq "")
  275.   )
  276.  
  277. (defun std11-address-string (address)
  278.   "Return string of address part from parsed ADDRESS of RFC 822.
  279. \[std11.el]"
  280.   (cond ((eq (car address) 'group)
  281.      (mapconcat (function std11-address-string)
  282.             (car (cdr address))
  283.             ", ")
  284.      )
  285.     ((eq (car address) 'mailbox)
  286.      (let ((addr (nth 1 address)))
  287.        (std11-addr-to-string
  288.         (if (eq (car addr) 'phrase-route-addr)
  289.         (nth 2 addr)
  290.           (cdr addr)
  291.           )
  292.         )))))
  293.  
  294. (defun std11-full-name-string (address)
  295.   "Return string of full-name part from parsed ADDRESS of RFC 822.
  296. \[std11.el]"
  297.   (cond ((eq (car address) 'group)
  298.      (mapconcat (function
  299.              (lambda (token)
  300.                (cdr token)
  301.                ))
  302.             (nth 1 address) "")
  303.      )
  304.     ((eq (car address) 'mailbox)
  305.      (let ((addr (nth 1 address))
  306.            (comment (nth 2 address))
  307.            phrase)
  308.        (if (eq (car addr) 'phrase-route-addr)
  309.            (setq phrase
  310.              (mapconcat
  311.               (function
  312.                (lambda (token)
  313.              (let ((type (car token)))
  314.                (cond ((eq type 'quoted-string)
  315.                   (std11-strip-quoted-pair (cdr token))
  316.                   )
  317.                  ((eq type 'comment)
  318.                   (concat
  319.                    "("
  320.                    (std11-strip-quoted-pair (cdr token))
  321.                    ")")
  322.                   )
  323.                  (t
  324.                   (cdr token)
  325.                   )))))
  326.               (nth 1 addr) ""))
  327.          )
  328.        (cond ((> (length phrase) 0) phrase)
  329.          (comment (std11-strip-quoted-pair comment))
  330.          )
  331.        ))))
  332.  
  333.  
  334. ;;; @ parser
  335. ;;;
  336.  
  337. (defun std11-parse-address-string (string)
  338.   "Parse STRING as mail address. [std11.el]"
  339.   (std11-parse-address (std11-lexical-analyze string))
  340.   )
  341.  
  342. (defun std11-parse-addresses-string (string)
  343.   "Parse STRING as mail address list. [std11.el]"
  344.   (std11-parse-addresses (std11-lexical-analyze string))
  345.   )
  346.  
  347. (defun std11-extract-address-components (string)
  348.   "Extract full name and canonical address from STRING.
  349. Returns a list of the form (FULL-NAME CANONICAL-ADDRESS).
  350. If no name can be extracted, FULL-NAME will be nil. [std11.el]"
  351.   (let* ((structure (car (std11-parse-address-string
  352.               (std11-unfold-string string))))
  353.          (phrase  (std11-full-name-string structure))
  354.          (address (std11-address-string structure))
  355.          )
  356.     (list phrase address)
  357.     ))
  358.  
  359. (provide 'std11)
  360.  
  361. (mapcar (function
  362.      (lambda (func)
  363.        (autoload func "std11-parse")
  364.        ))
  365.     '(std11-lexical-analyze
  366.       std11-parse-address std11-parse-addresses
  367.       std11-parse-address-string))
  368.  
  369.  
  370. ;;; @ end
  371. ;;;
  372.  
  373. ;;; std11.el ends here
  374.